Technotools/Technotools (Chestnut CD-ROM)(1993).ISO/database/vbpxen/pxmodule.bas

BASIC Source File | 1991-10-07 | 14KB | 417 lines

'
'  Written by Steve Jackson
'             9152 Brabham Drive
'             Huntington Beach, CA 92646
'
'  Thanks to John Jaster for some of the dll definitions
'
'  Most of the engine functions are defined here, but not all.
'  One that I have not gotten to work is PxErrMsg because it returns
'  a pointer.  Visual Basic has no pointer types (that I know of).
'  You might get it to work by get a pointer to windows memory and
'  using that, but it is beyond me right now.
'
'  This module is meant to be a general purpose visual basic interface
'  to the Paradox engine DLL.  To run it, you need the DLL from Paradox
'  Engine.  An example of usage is distributed in little video rental
'  application called VVDEMO.
'
'  Comments, questions are welcome.  If you know of any ways I can
'  earn a little extra income to purchase a faster computer (and with
'  more memory) that would be welcome too.
'
'******* Declarations for Using the Paradox 3.5 Engine ******
Declare Function PXWinInit Lib "Pxengwin.dll" (ByVal Application$, ByVal Mode%) As Integer
Declare Function PXExit Lib "Pxengwin.dll" () As Integer
'************ TABLE FUNCTIONS *****************
Declare Function PXTblOpen Lib "Pxengwin.dll" (ByVal TblName$, TblHnd%, ByVal index%, ByVal change%) As Integer
Declare Function PXTblClose Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
'************* RECORD FUNCTIONS *******************
Declare Function PXRecAppend Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%) As Integer
Declare Function PXRecInsert Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%) As Integer
Declare Function PXRecUpdate Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%) As Integer
Declare Function PXRecDelete Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
Declare Function PXRecBufOpen Lib "Pxengwin.dll" (ByVal TblHnd%, RecHnd%) As Integer
Declare Function PXRecBufClose Lib "Pxengwin.dll" (ByVal RecHnd%) As Integer
Declare Function PXRecBufEmpty Lib "Pxengwin.dll" (ByVal RecHnd%) As Integer
Declare Function PXRecGet Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%) As Integer
Declare Function PXRecFirst Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
Declare Function PXRecLast Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
Declare Function PXRecNext Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
Declare Function PXRecPrev Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
Declare Function PXRecNum Lib "Pxengwin.dll" (ByVal TblHnd%, RecNum%) As Integer
Declare Function PXTblNRecs Lib "Pxengwin.dll" (ByVal TblHnd%, nRecs%) As Integer
'**************** FIELD FUNCTIONS ****************
Declare Function PXPutShort Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal sValue%) As Integer
Declare Function PXPutDoub Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal dValue#) As Integer
Declare Function PXPutLong Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal lValue&) As Integer
Declare Function PXPutAlpha Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal aValue$) As Integer
Declare Function PXPutBlank Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%) As Integer
Declare Function PXPutDate Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal inDate As Any) As Integer
Declare Function PXGetShort Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, sValue%) As Integer
Declare Function PXGetDoub Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, dValue#) As Integer
Declare Function PXGetLong Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, lValue&) As Integer
Declare Function PXGetAlpha Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal bufSize%, ByVal aValue$) As Integer
Declare Function PXFldBlank Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, Blank%) As Integer
Declare Function PXGetDate Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, outDate As Any) As Integer
Declare Function PXRecNFlds Lib "Pxengwin.dll" (ByVal TblHnd%, nFlds%) As Integer
Declare Function PXFldHandle Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal FldName$, FldHnd%) As Integer
Declare Function PXFldType Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal FldHnd%, ByVal BufSiz%, ByVal fldtype$) As Integer
Declare Function PXFldName Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal FldHnd%, ByVal BufSiz%, ByVal FldName$) As Integer
'*************** SEARCH FUNCTIONS *******************
Declare Function PXSrchKey Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%, ByVal nFlds%, ByVal Mode%) As Integer
Declare Function PXSrchFld Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%, ByVal FldNum%, ByVal Mode%) As Integer
'***************** MISCELLANEOUS FUNCTIONS ****************
Declare Function PXDateDecode Lib "Pxengwin.dll" (ByVal outDate As Any, mm%, dd%, yy%) As Integer
Declare Function PXDateEncode Lib "Pxengwin.dll" (ByVal mm%, ByVal dd%, ByVal yy%, pDate&) As Integer
' note: PXErrMsg returns a string, not an integer
Declare Function PXErrMsg Lib "Pxengwin.dll" (ByVal error_code%) As String
'******************* NETWORK FUNCTIONS ******************
Declare Function PXNetUserName Lib "Pxengwin.dll" (ByVal buffer%, UserName$) As Integer
Declare Function PXNetFileLock Lib "Pxengwin.dll" (ByVal FileName$, ByVal lockType%) As Integer
Declare Function PXNetFileUnlock Lib "Pxengwin.dll" (ByVal FileName$, ByVal lockType%) As Integer
Declare Function PXNetTblLock Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal lockType%) As Integer
Declare Function PXNetTblUnlock Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal lockType%) As Integer
Declare Function PXNetRecLock Lib "Pxengwin.dll" (ByVal TblHnd%, LockHnd%) As Integer
Declare Function PXNetRecUnlock Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal LockHnd%) As Integer
Declare Function PXNetRecLocked Lib "Pxengwin.dll" (ByVal TblHnd%, Locked%) As Integer
Declare Function PXNetTblChanged Lib "Pxengwin.dll" (ByVal TblHnd%, Changed%) As Integer
Declare Function PXNetTblRefresh Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
'
' Variables used only in this module
'
' What must be defined in global:  NUMBER_OF_TABLES
'
'
Dim hTable(NUMBER_OF_TABLES) As Integer
Dim hRecBuf(NUMBER_OF_TABLES) As Integer
Dim hRecLock(NUMBER_OF_TABLES) As Integer
Dim iTableIsClosed(NUMBER_OF_TABLES) As Integer

Dim alpha_field As String * 256
Dim px As Integer

Const PX_OK = 0
Const PX_ENDOFTABLE = 101
Const PX_STARTOFTABLE = 102
Const PX_RECNOTFOUND = 89
Const PX_KEYVIOL = 97
Const PX_RECDELETED = 50
Const PX_RECLOCKED = 9

Sub PXError (ByVal error_code As Integer)
    '
    '  General purpose error trapping.
    '  If the error is not critical (that is, the database is OK),
    '  return to the user.  Store message that they can retrieve if
    '  needed by calling dberrormsg().
    '
    '  If the error is critical, processing cannot continue, and
    '  this routine will END THE PROGRAM
    '
    If error_code = PX_OK Then
        Exit Sub
    End If
    '
    '   Non-critical errors:
    '
    Select Case error_code
        Case PX_OK
            Exit Sub
        Case PX_ENDOFTABLE, PX_STARTOFTABLE, PX_KEYVIOL
            Exit Sub
        Case PX_RECNOTFOUND, PX_RECDELETED
            Exit Sub
    End Select

    Msg$ = "Paradox database error code: " + Str$(error_code)
    ' alpha_field = PXErrMsg(error_code)
    ' Msg$ = Msg$ + alpha_field
    MsgBox Msg$, 0 + 16, "Database Error"
    End
End Sub

Function DBInit (ByVal AppName$) As Integer
    '
    ' Start the paradox engine for windows
    ' for now always use mode of: PXSHARED
    '
    px = PXWinInit(AppName$, 2)
    If px = 82 Then
        DBInit = PX_OK
        Exit Function
    End If

    If px Then
        Msg$ = "Unable to start Paradox engine, code: " + Str$(px)
        Msg$ = Msg$ + " Remember to type SHARE before starting Windows"
        MsgBox Msg$, 0 + 16, "Database Initialization"
        End
    End If

    DBInit = PX_OK
End Function

Function DBExit () As Integer
    '
    '  Shutdown the paradox engine
    '
    DBExit = PXExit()
End Function

Function TableOpen (ByVal Tblnum%, ByVal TblName$)
    '
    '  Open a table and allocate one record buffer for it.
    '  Application calls this routine once for each table.
    '  Note that it creates table and record handles for use in
    '  other database routines.  They get the correct handles by
    '  indexing into the handle array with the application assigned
    '  table id - should be a const in their global declaration,
    '  and MUST be sequentially assigned starting at ZERO.
    '
    px = PXTblOpen(TblName$, TblHnd%, 0, TRUE)
    PXError (px)

    px = PXRecBufOpen(TblHnd%, RecHnd%)
    PXError (px)

    px = PXRecBufEmpty(RecHnd%)
    PXError (px)

    hTable(Tblnum%) = TblHnd%
    hRecBuf(Tblnum%) = RecHnd%

    TableOpen = PX_OK
End Function

Function GetRec (ByVal Tblnum%, ByVal Action%)
    '
    '  Get a record and move it to the record buffer.
    '  Note that it uses table and record handles created in TableOpen()
    '
    hTbl% = hTable(Tblnum%)
    hrec% = hRecBuf(Tblnum%)

    Select Case Action%
         Case DBKEYED
            px = PXSrchKey(hTbl%, hrec%, 1, 0)
            PXError (px)
         Case DBFIRST
            px = PXRecFirst(hTbl%)
            '  check for end, not found, etc.
            PXError (px)
         Case DBNEXT
            px = PXRecNext(hTbl%)
            PXError (px)
         Case DBPRIOR
            px = PXRecPrev(hTbl%)
            PXError (px)
         Case DBLAST
            px = PXRecLast(hTbl%)
            PXError (px)
    End Select

    If px Then
        GetRec = px
        Exit Function
    End If

    px = PXRecGet(hTbl%, hrec%)
    PXError (px)

    GetRec = PX_OK
End Function

'
Function UpdateRec (ByVal Tblnum%) As Integer
    '
    '  Uupdate the record that is current  (last one retrieved)
    '
    hTbl% = hTable(Tblnum%)
    hrec% = hRecBuf(Tblnum%)

    px = PXRecUpdate(hTbl%, hrec%)
    PXError (px)

    UpdateRec = px

End Function

Function AddRec (ByVal Tblnum%) As Integer
    '
    '  Add a new record.  If file is not indexed, goes at end
    '
    hTbl% = hTable(Tblnum%)
    hrec% = hRecBuf(Tblnum%)

    px = PXRecAppend(hTbl%, hrec%)
    PXError (px)

    AddRec = px

End Function

Function DeleteRec (ByVal Tblnum%) As Integer
    '
    '  Delete current record (most recently retrieved)
    '
    hTbl% = hTable(Tblnum%)

    px = PXRecDelete(hTbl%)
    PXError (px)

    DeleteRec = px

End Function

Function PutAlphaField (ByVal TableNum%, ByVal FieldNum%, ByVal FieldVal$) As Integer
    '
    '  Move field to paradox buffer
    '
    hrec% = hRecBuf(TableNum%)
    alpha_field = FieldVal$

    px = PXPutAlpha(hrec%, FieldNum%, alpha_field)
    PXError (px)

    PutAlphaField = PX_OK

End Function

Function PutShortField (ByVal TableNum%, ByVal FieldNum%, ByVal ShortVal%) As Integer
    '
    '  Move field to paradox buffer
    '
    hrec% = hRecBuf(TableNum%)

    px = PXPutShort(hrec%, FieldNum%, ShortVal%)
    PXError (px)

    PutShortField = PX_OK

End Function

Function PutNumField (ByVal TableNum%, ByVal FieldNum%, ByVal NumVal) As Integer
    Dim nDouble As Double
    '
    '  Move field to paradox buffer
    '
    hrec% = hRecBuf(TableNum%)
    nDouble = NumVal

    px = PXPutDoub(hrec%, FieldNum%, nDouble)
    PXError (px)

    PutNumField = PX_OK

End Function

Function GetAlphaField (ByVal TableNum%, ByVal FieldNum%, FieldVal$) As Integer
    Dim IsBlank As Integer
    '
    '  Get field from paradox buffer to user buffer
    '
    hrec% = hRecBuf(TableNum)

    px = PXFldBlank(hrec%, FieldNum%, IsBlank)
    PXError (px)

    If IsBlank Then
        FieldVal$ = " "
        GetAlphaField = PX_OK
        Exit Function
    End If

    px = PXGetAlpha(hrec%, FieldNum%, 255, alpha_field)
    PXError (px)

    FieldVal$ = alpha_field
    GetAlphaField = PX_OK
End Function

Function GetShortField (ByVal TableNum%, ByVal FieldNum%, ShortVal%) As Integer
    '
    '  Get field from paradox buffer to user buffer
    '
    Dim iShort As Integer

    hrec% = hRecBuf(TableNum)

    px = PXGetShort(hrec%, FieldNum%, iShort)
    PXError (px)

    ShortVal% = iShort
    GetShortField = PX_OK
End Function

Function GetNumField (ByVal TableNum%, ByVal FieldNum%, NumVal) As Integer
    '
    '  Get field from paradox buffer to user buffer
    '
    Dim nDouble As Double

    hrec% = hRecBuf(TableNum)

    px = PXGetDoub(hrec%, FieldNum%, nDouble)
    PXError (px)

    NumVal = nDouble
    GetNumField = PX_OK
End Function

Function LockRec (ByVal Tblnum%) As Integer
    Dim iLockHandle As Integer
    '
    '  Lock the record that is current  (last one retrieved)
    '
    hTbl% = hTable(Tblnum%)

    px = PXNetRecLock(hTbl%, iLockHandle)
    If px = PX_RECLOCKED Then
        LockRec = DB_RECLOCKED
        Exit Function
    End If
    '
    '  check for any other critical error
    '
    PXError (px)

    hRecLock(Tblnum%) = iLockHandle

    LockRec = px
End Function

Function UnlockRec (ByVal Tblnum%) As Integer
    Dim iLockHandle As Integer
    '
    '  Unock a record.
    '  In this version, only one record per table can be
    '  locked at any time.  Could change in the future
    '
    hTbl% = hTable(Tblnum%)
    iLockHandle = hRecLock(Tblnum%)
    '
    '  If no record is locked, exit the function
    '
    If iLockHandle = 0 Then
        UnlockRec = DB_OK
        Exit Function
    End If

    px = PXNetRecUnlock(hTbl%, iLockHandle)
    '
    '  If the unlock failed, just go ahead and return
    '  This is REALLY sloppy coding, should be fixed soon
    '
    If px = 110 Then
        UnlockRec = PX_SUCCESS
        Exit Function
    End If

    PXError (px)

    hRecLock(Tblnum%) = 0
    UnlockRec = px
End Function